home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
The World of Computer Software.iso
/
faq-s.zip
/
QUOTES.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-04-13
|
12KB
|
477 lines
{$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }
{$M 65500,0,0 }
unit quotes;
interface
uses crt,dos,
gentypes,configrt,modem,statret,gensubs,subs1,windows,subs2;
procedure quotemenu;
procedure randomquote;
implementation
procedure quotemenu;
var r,ar:quoterec;
function numquotes:integer;
begin
numquotes:=filesize(rfile)
end;
procedure seekrfile (n:integer);
begin
seek (rfile,n-1)
end;
procedure openrfile;
var n:integer;
begin
n:=ioresult;
assign (rfile,bbsdatadir+'Rumors.dat');
reset (rfile);
if ioresult<>0 then begin
close (rfile);
n:=ioresult;
rewrite (rfile)
end
end;
procedure listquotes;
var cnt:integer;
b:boolean;
n1,n2:integer;
begin
writeln;
ansireset;
if numquotes<1 then begin
writeln ('There are no Quotes!');
exit;
end;
b:=true;
seekrfile (1);
writehdr ('Quotes List');
parserange (numquotes,n1,n2);
if n1=0 then exit;
for cnt:=n1 to n2 do begin
read (rfile,r);
if b then begin
writeln
(^P'#'^S' Title '^U'Date '^R'Author');
if ascii then
writeln
(^S'────────────────────────────────────────────────────────────────────────'^M^R);
b:=false
end;
ansicolor (urec.promptcolor);
tab (strr(cnt),4);
ansicolor (urec.statcolor);
tab (r.title,30);
ansicolor (urec.inputcolor);
tab (datestr(r.when),10);
ansicolor (urec.regularcolor);
if r.author='...!@ANON#$...' then
begin
write ('<Anonymous>');
if ulvl>=readanonlvl then write (^R,' ['^S,r.author2,^R']');
writeln;
end
else writeln (^S,r.author);
ansireset;
if break then exit;
ansicolor (urec.regularcolor);
end;
if b then writestr ('There are no Quotes!')
end;
function getrnum (txt:mstr):integer;
var n:integer;
begin
getrnum:=0;
repeat
writeln;
writestr ('Quote Number to '+txt+' [?/List]:');
if length(input)=0 then exit;
if upcase(input[1])='?'
then listquotes
else begin
n:=valu(input);
if (n<1) or (n>numquotes) then begin
writestr (^M'Number out of range!');
exit
end;
seekrfile (n);
read (rfile,r);
if (ulvl<r.level) and (not issysop) then exit;
getrnum:=n;
exit
end
until hungupon
end;
procedure showquote (n:integer);
var rr:quoterec;
begin
seekrfile (n);
read (rfile,rr);
if ulvl<rr.level then exit;
writeln;
ansicolor (urec.regularcolor);
write ('"');
ansicolor (urec.statcolor);
write (rr.quote);
ansicolor (urec.regularcolor);
writeln ('"');
ansireset;
end;
procedure addquote;
var x,b:boolean;
y,t:text;
cdir,cddir:lstr;
n:integer;
z:anystr;
apecks:quoterec;
function matchtitle (f:sstr):integer;
var cnt:integer;
monark:quoterec;
begin
for cnt:=1 to numquotes do begin
seekrfile (cnt);
read (rfile,monark);
if match (monark.title,f) then begin
matchtitle:=cnt;
ansireset;
exit
end
end;
matchtitle:=0
end;
begin
if ulvl<2 then begin
reqlevel (2);
exit
end;
if numquotes>=999 then begin
writeln;
writeln ('Sorry, there are too many quotes now!');
writeln ('Ask your Sysop to delete some.');
exit
end;
ansireset;
writehdr ('Add a Quote');
buflen:=30;
writeln (' [------------------------------]');
writestr('Title: &');
apecks.title:=input;
if length(input)=0 then exit;
if matchtitle(apecks.title)>0 then begin
writeln;
writeln ('Sorry, that Quote already exists! Try another Title!');
exit
end;
apecks.level:=1;
apecks.author:=unam;
apecks.author2:=unam;
writeln;
if ulvl>=anonymouslevel then begin
writestr ('Post Quote Anonymous [y/n]? &');
if yes then apecks.author:='...!@ANON#$...' else
apecks.author:=unam;
end;
apecks.when:=now;
ansireset;
writeln;
writestr ('Level required to read Quote [CR/1]: &');
if length(input)=0 then apecks.level:=1 else
apecks.level:=valu(input);
writeln;
writeln ('Enter Quote [CR to Abort]');
buflen:=78;
writeln (' [---------------------------------------------------------------------------]');
writestr('> &');
if input='' then exit;
b:=true;
apecks.quote:=input;
seekrfile (numquotes+1);
write (rfile,apecks);
if b then writeln (^M'Quote created!');
if not b then begin
exit
end;
end;
procedure deletequote;
var cnt,n:integer;
f:file;
begin
n:=getrnum ('Delete');
if n=0 then exit;
seekrfile (n);
read (rfile,r);
if not issysop then
if not match(r.author2,unam) then
begin
writeln;
writeln ('You didn''t post that!!');
writeln;
exit
end;
writeln;
ansicolor (urec.regularcolor);
write ('"');
ansicolor (urec.statcolor);
write (r.quote);
ansicolor (urec.regularcolor);
writeln ('"');
writeln;
writestr ('Delete this Quote? [y/n]: *');
if not yes then exit;
for cnt:=n+1 to numquotes do begin
seekrfile (cnt);
read (rfile,r);
seekrfile (cnt-1);
write (rfile,r);
end;
seekrfile (numquotes);
truncate (rfile);
writelog (1,8,r.title)
end;
const beenaborted:boolean=false;
function aborted:boolean;
begin
if beenaborted then begin
aborted:=true;
exit
end;
aborted:=xpressed or hungupon;
if xpressed then begin
beenaborted:=true;
writeln (^R'Newscan aborted!')
end
end;
procedure quotesnewscan;
var first,cnt:integer;
nd:boolean;
re:quoterec;
begin
writehdr ('Quotes Newscan');
if numquotes<1 then exit;
for cnt:=1 to numquotes do begin
seekrfile (cnt);
read (rfile,re);
if (re.when>laston) and (ulvl>=re.level) then begin
ansicolor (urec.inputcolor);
tab (strr(cnt)+'.',4);
ansicolor (urec.promptcolor);
write (re.title);
ansicolor (urec.regularcolor);
write (' by ');
ansicolor (urec.inputcolor);
if re.author='...!@ANON#$...' then
write ('<Anonymous>') else write (re.author2);
writeln;
ansicolor (urec.regularcolor);
write (' "');
ansicolor (urec.statcolor);
write (re.quote);
ansicolor (urec.regularcolor);
writeln ('"');
end;
end;
end;
procedure searchfortext;
var x:integer;
mixmasterfag:boolean;
s:anystr;
rr:quoterec;
begin
if numquotes<1 then begin
writeln (^M'No Quotes Exist!'^M);
exit;
end;
writehdr ('Search for Text in all Quotes');
writeln ('Enter Text to search for:');
writestr ('-> &');
writeln;
if length(input)=0 then exit;
s:=input;
s:=upstring(s);
for x:=1 to numquotes do begin
mixmasterfag:=false;
seekrfile (x);
read (rfile,rr);
if pos(s,upstring(rr.title))>0 then mixmasterfag:=true;
if pos(s,upstring(rr.quote))>0 then mixmasterfag:=true;
if pos(s,upstring(rr.author))>0 then mixmasterfag:=true;
if ((ulvl>=readanonlvl) and (pos(s,upstring(rr.author2))>0)) then mixmasterfag:=true;
if (mixmasterfag=true) and (ulvl>=rr.level) then begin
ansicolor (urec.inputcolor);
tab (strr(x)+'.',4);
ansicolor (urec.promptcolor);
write (rr.title);
ansicolor (urec.regularcolor);
write (' by ');
ansicolor (urec.inputcolor);
if rr.author='...!@ANON#$...' then
write ('<Anonymous>') else write (rr.author2);
writeln;
ansicolor (urec.regularcolor);
write (' "');
ansicolor (urec.statcolor);
write (rr.quote);
ansicolor (urec.regularcolor);
writeln ('"');
end;
end;
end;
procedure explainquotes;
begin
if exist (textfiledir+'Quotes.Hlp') then
printfile (textfiledir+'Quotes.Hlp') else
begin
writehdr ('Quotes Explanation');
writeln;
writeln ('Quotes are sayings that a user can make and the quote will');
writeln ('randomly appear at the Main Menu prompt. You can Add, View,');
writeln ('and Delete quotes (you can only Delete quotes if you are a');
writeln ('Sysop or if you posted that quote). You can also set a level');
writeln ('required to see that particular quote. ');
writeln;
end;
end;
label later;
var prompt:lstr;
n,q,b:integer;
k:char;
mp:boolean;
begin
if not usequote then begin
writeln;
writeln ('Quotes are not in use!');
writeln;
exit;
end;
openrfile;
mp:=moreprompts in urec.config;
if mp then urec.config:=urec.config-[moreprompts];
writehdr ('Quotes');
repeat
q:=menu ('Quotes','QUOTE','LAD#EQNS?');
writeln;
if q<0 then begin
b:=-q;
if (b<0) or (b>numquotes) then
writeln (^M'Number out of range!') else
showquote (b);
end else
case q of
1:listquotes;
2:addquote;
3:deletequote;
5:explainquotes;
7:quotesnewscan;
8:searchfortext;
9:begin
writeln ('
C
╔═════════════════════════════════════╗H
s');
writeln ('u
C║
Quotes Section
║H
s');
writeln ('u
C╚═════════════════════════════════════╝HHC╔════
s');
writeln ('u
═════════════════════════════════╗HC║ [
A
]
s');
writeln ('u
Add Quote
║HC║ [
D
s');
writeln ('u
]
Delete Quote
║HC║ [
s');
writeln ('u
E
]
Explanation of Quote
║H
s');
writeln ('u
C║ [
N
]
Newscan all Quotes
s');
writeln ('u
║HC║ [
Q
]
Quit
s');
writeln ('u
║HC║ [
S
]
Search Quotes for
s');
writeln ('u
Text
║HC║ [
#
]
Read Quote
s');
writeln ('u
#
║HC║ [
?
]
Vie
s');
writeln ('u
w This Menu
║HC╚═════════════════
A');
writeln ('C
════════════════════╝
');
writeln;
pause;
end;
end;
until (q=6) or (hungupon);
later:
close (rfile);
if mp then urec.config:=urec.config+[moreprompts];
end;
procedure randomquote;
function numquotes:integer;
begin
numquotes:=filesize(rfile)
end;
procedure seekrfile (n:integer);
begin
seek (rfile,n-1)
end;
procedure openrfile;
var n:integer;
begin
n:=ioresult;
assign (rfile,bbsdatadir+'Rumors.dat');
reset (rfile);
if ioresult<>0 then begin
close (rfile);
n:=ioresult;
rewrite (rfile)
end
end;
procedure showit (n:integer);
var rr:quoterec;
begin
seekrfile (n);
read (rfile,rr);
if ulvl<rr.level then exit;
writeln;
ansicolor (urec.regularcolor);
write ('"');
ansicolor (urec.statcolor);
write (rr.quote);
ansicolor (urec.regularcolor);
writeln ('"');
ansireset;
end;
var x:integer;
begin
if not usequote then exit;
openrfile;
if numquotes<1 then begin
writeln;
ansicolor (urec.regularcolor);
write ('"');
ansicolor (urec.statcolor);
write (^S'Make a Quote with '^R'"'^S'Q'^R'"'^S'.');
ansicolor (urec.regularcolor);
writeln ('"');
ansireset;
end else
begin
seekrfile (1);
randomize;
x:=random (numquotes+1);
showit (x);
end;
close (rfile);
ansireset;
end;
begin
end.